
package Sgdb::DataActions ;

use Sgdb::Utils qw (:DEFAULT
                    ) ;



# pragmas for all
use warnings ;
use strict ;
use integer ;
use bytes ;

my %tp ;
my ($tact, $text ) ;
my $action_prompt = qr/Action|Stepping|^\s*\>/m ;

sub new {

    my ($self, $frame) = @_ ;


    my $t = $text = $frame -> Text ( -wrap => 'word',
                                     pref ('set-actions-text'),
                                     ) ;

    hook_add ( 'set-tracepoint-action' => [\&set_actions] ) ;

    $t -> menu() -> delete ( 0 ) ;
    $t -> bind ("<Meta-Up>",     sub {}) ;
    $t -> bind ("<Meta-Down>",   sub {}) ;

    my $bg = $t -> cget( '-background' ) ;

    $frame -> configure ( -background => $bg ) ;

    my $f = $frame -> Frame( -background => $bg ,
                             -relief => 'ridge',
                             ) -> pack ( -fill => 'x',
                                         -expand => 1,
                                         -pady => 0,
                                         ) ;


    my @pref_button  = ( -width => 7 ,pref 'set-actions-button' ) ;
    my @pref_entry   = ( pref 'set-actions-entry' ) ;
    my @pack_left    = ( -side => 'left', -anchor => 'w' ) ;

    my $b ;

    # Save
    $b = $f -> Button ( -text => 'Save',
                        -command => [\&try_to_save_actions],
                        @pref_button
                      ) -> pack ( -padx => 5,
                                  @pack_left
                                ) ;

    pref_reconfigure 'set-actions-button', $b ;
    balloonset $b => <<DoC ;
Save actions configured
for this tracepoint. Actions
are associated with a tracepoint 
sequence number.
DoC

    # Close
    $b = $f -> Button ( -text => 'Close',
                        -command => [\&hook_run, 'close-current-data-pane'],
                        @pref_button
                      ) -> pack ( -padx => 5,
                                  @pack_left,
                                ) ;

    pref_reconfigure 'set-actions-button', $b ;
    balloonset $b => <<DoC ;
Close this pane without saving changes.
DoC

    $f -> Label ( -text => 'tracepoint', -background => $bg,
                  ) -> pack ( @pack_left ) ;

    my $tpnum = $f -> Entry ( -textvariable => \$tp{num} ,
                              -width => 3 ,
#                               -invalidcommand => [$mainwindow => 'bell'] ,
                              -validate    => 'key',
                              -vcmd        => sub {shift =~ /^\d*$/},
                              @pref_entry
                              ) -> pack ( @pack_left ) ;
    balloonset $tpnum => <<DoC ;
The sequence number associated
with the current tracepoint \(address\). 
Enter a different sequence number to 
display properties of another tracepoint.
DoC

    $f -> Label ( -textvariable => \$tp{inwhat}, -background => $bg,
                  ) -> pack ( @pack_left ) ;

    $tact = $t -> Text (-width => ($t->cget('-width') -2),
                        -height => 7,
                        pref ('set-actions-actions-text')
                        ) ;
    balloonset $tact => <<DoC ;
Specify actions performed
at this tracepoint. If you 
use the GUI, select actions 
above (example: collect), 
then choose the arguments
beneath (example: registers...).
DoC

    $tact -> menu() -> delete ( 0 ) ;
    $tact -> bind ("<Meta-Up>",     sub {}) ;
    $tact -> bind ("<Meta-Down>",   sub {}) ;

    my $passcount = $t -> Entry ( -textvariable => \$tp{passcount},
                                  -width => 4,
#                                   -invalidcommand => [$mainwindow => 'bell'] ,
                                  -validate    => 'key',
                                  -vcmd        => sub {shift =~ /^\d*$/},
                                  @pref_entry
                                  ) ;

    balloonset $passcount => <<DoC ;
Passcount defines the number of passes through the 
tracepoint upon which Sgdb stops collecting data.
Example: If passcount is set to 3, Sgdb will stop 
collecting data when the code passes the tracepoint 
for the third time.

DoC

    cup_for_text_and_actions ( $passcount, $tpnum ) ;

    pref_reconfigure ( 'set-actions-entry' => $passcount => $tpnum ,
                       'set-actions-text' => $text => $tact
                       ) ;

    $t -> pack () ;
}

sub cup_for_text_and_actions {

    my $t = $text ;
    my ($passcount, $tpnum) = @_ ;

    $passcount->bind ("<Up>"   => sub { $tp{passcount} ++ }) ;
    $passcount->bind ("<Down>" => sub { $tp{passcount} --    if $tp{passcount}    }) ;
    $passcount->bind ("<Prior>"=> sub { $tp{passcount} += 10 }) ;
    $passcount->bind ("<Next>" => sub { $tp{passcount} -= 10 if $tp{passcount} > 9}) ;

    $tpnum ->bind ("<Up>"     => sub { busy ; set_actions($tp{num} +1)            ; unbusy }) ;
    $tpnum ->bind ("<Down>"   => sub { busy ; set_actions($tp{num} -1) if $tp{num}; unbusy }) ;
    $tpnum ->bind ("<Return>" => sub { busy ; set_actions($tp{num}   )            ; unbusy }) ;

    $t -> insert ( 'end',
                   "\nActions: (" => 'btext',
                   'collect'      => 'glink',
                   ', '           => 'btext',
                   'disable'      => 'glink',
                   ', '           => 'btext',
                   'enable'       => 'glink',
                   ', '           => 'btext',
                   'ignore'       => 'glink',
                   ', '           => 'btext',
                   'sfunc'        => 'glink',
                   ', '           => 'btext',
                   'set'          => 'glink',
                   ', '           => 'btext',
                   'stepping'     => 'glink',
                   ', '           => 'btext',
                   'stop'         => 'glink',
                   ', '           => 'btext',
                   'end'          => 'glink',
                   ")  Passcount: " => 'btext',
                   ) ;

    $t -> windowCreate ( 'end',
                         -window => $passcount
                         ) ;

    $t -> insert ( 'end', "\n" ) ;

    $t -> windowCreate ( 'end',
                         -window => $tact,
                         -align => 'center'
                         ) ;

    $t -> insert ( 'end',
                   "\nquick collect: " => 'b-text'
                   ) ;

    $t -> insert ('end',
                  'registers'    => 'glink',
                  ', '           => 'btext',
		  'allregisters' => 'glink',
		  ', '           => 'btext',
                  'locals'       => 'glink',
                  ', '           => 'btext',
                  'args'         => 'glink',
                  " "
                  ) ;

    $t -> markSet ('quicky', 'end -1 c') ;
    $t -> markGravity ('quicky', 'left') ;

    pref_tags $t, 'set-actions', qw/glink llink btext gtext rtext/ ;
    pref_tags $tact, 'set-actions', qw/actions clues hlight/ ;

    $t -> tagBind ( 'glink', '<1>', \&handle_clicked_glink) ;
    $t -> tagBind ( 'llink', '<1>', \&handle_clicked_llink) ;
    $t -> tagBind ( 'glink', '<Enter>', [$t, 'configure', -cursor => 'arrow'] ) ;
    $t -> tagBind ( 'glink', '<Leave>', [$t, 'configure', -cursor => 'xterm'] ) ;
    $t -> tagBind ( 'llink', '<Enter>', [$t, 'configure', -cursor => 'arrow'] ) ;
    $t -> tagBind ( 'llink', '<Leave>', [$t, 'configure', -cursor => 'xterm'] ) ;

#    $tact -> bind    ( '<KeyPress-Tab>', [$tact, 'break']) ;
    $tact -> bind    ( '<KeyRelease-Tab>',\&complete_action) ;

    $t -> configure (-state => 'disabled' ) ;
}

sub handle_clicked_glink {

    my $w = text_current_word $text, 'current';
# $text -> get ('current wordstart' => 'current wordend' ) ;

                                # actions to be completed by user
    foreach my $exp
         ([ 'ignore',
            'ignore if EXPR <== do not collect frame data if EXPR will be non zero'],
          [ 'collect',
            'collect EXPR <== expression to be collected in this trace'],
          [ 'stepping',
            'stepping NUM <== number of steps to execute the subsequent actions ("end" terminated)'],
          [ 'stop',
            'stop if EXPR <== stop all traces if EXPR will be non zero'],
          [ 'disable',
            'disable N if EXPR <== disable tracepoint N if EXPR will be non zero'],
          [ 'enable',
            'enable N if EXPR <== enable tracepoint N if EXPR will be non zero'],
          [ 'sfunc',
            'sfunc (A,B,C) if EXPR <== call scratch function with arguments A, B, C if EXPR will be non zero'],
          [ 'set',
            'set a = b if EXPR <== set variable a to value b if EXPR will be non zero'],
          [ 'end',
            ' ']
          ) {

             next if $exp->[0] ne $w ;

             $w .= ' 10' if $w eq 'stepping' ; # by Eli's special request ...

             action_comment( $exp->[1] ) ;

             $tact -> focus() ;
             $tact -> insert ('end',
                              "\n$w " => 'actions'
                              ) ;

             $tact -> markSet ('current' => 'end' ) ;
             $tact -> see ('current' ) ;
             return ;
         }

    add_quick_collect( "\$$w" ) ;
}

sub handle_clicked_llink {

    my ($w, $s) = text_current_word $text, 'current'; #    $w = $text -> get ('current wordstart' => 'current wordend' ) ;
    return unless $w =~ /\w/  ;
    $w = "*$w" if $text -> get ("$s -1 c") eq '*' ;
    add_quick_collect( $w ) ;
}

sub add_quick_collect {

    action_comment() ;

    my $w = shift ;

    my @actions = reverse split /^/, $tact -> get ('1.0' => 'end') ;
    chomp @actions ;

    foreach my $line ( @actions ) {

        next if $line !~ /\w/ or $line =~ /^\s*\#/ ;
        last if $line !~ /^\s*col/ ;
        if ( $line =~ /^\s* col\w*\s+ \Q$w\E \s*(?:, |$ )/x or
             $line =~ /^\s* col.*,\s* \Q$w\E \s*(?:, |$ )/x
             ) {

            action_comment( "$w: already collected" ) ;
            return ;
        }
    }

    my $pre ;
    my $line = shift @actions ;

    if    (!$line or $line !~ /\w/ ) {

        $pre = 'collect' ;
    }
    elsif ( $line =~ /^\s*col/ and
            length ($line) + length( $w ) < $tact -> cget('-width') -2 ) {
        $pre = ',' ;
    }
    else {
        $pre = "\ncollect" ;
    }

    $tact -> insert ('end',
                     "$pre $w" => 'actions'
                     );

}

sub action_comment {

    my $comment = shift || '' ;
    my $tag = shift || 'gtext' ;
    $text -> configure (-state => 'normal' ) ;
    $text -> delete ('1.0' => '1.0 lineend' ) ;
    $text -> insert ('1.0', $comment => $tag ) ;
    $text -> configure (-state => 'disabled' ) ;
}

sub starless ($) { shift =~ /^\*?(.*)/ ; $1 }

sub set_actions {

    return unless istkwidget $text ;

    @tp{ qw /num addr file line/ } = @_ ;
    my $where ;

    $tp{num} ||= 1 ;

    my $str = gdb_exec_quiet ("i tracepoints " . $tp{num}) || '' ;

    1 while $str =~ s/end\s*$//s ;

    my @lines = split /^/, $str ;

    $tact -> configure (-state => 'normal' ) ;
    $tact -> delete ('1.0' => 'end' ) ;
    $text -> configure (-state => 'normal' ) ;
    $text -> delete ('quicky' => 'end' ) ;
    $text -> delete ('1.0' => '1.0 lineend' ) ;

    while ($str = shift @lines ) {
        $str =~ /^Num/ or next ;
        $str = shift @lines ;
        last ;
    }

    if ( $str and $str =~ m[^(\d+)       \s+
                            (y|n)        \s+
                            ([\dxa-f]+)  \s+
                            (\d+)        \s+
                            \d+          \s+
                            (.*)
                            ]xo ) {

        @tp{ qw/num enable addr passcount inwhat exists/ } = ($1, $2, $3, $4, " $5 ($3)", 1) ;
        $where = '*' . $tp{addr} ;
    }
    else {

        telthem "trace $tp{num}: not exists" ;
        action_comment( "trace $tp{num}: not exists", 'rtext' ) ;
        # NOTE: action_comment will configure $text to 'disabled'
        # $text -> configure (-state => 'disabled' ) ;
        $tact -> configure (-state => 'disabled' ) ;
        telme $str if $str ;
        return ;
                                # TODO:
        if    ($tp{addr} and
               $tp{addr} =~ /^0x[\da-f]+$/ ) {

            $where = '*' . $tp{addr} ;
        }
        elsif ($tp{file} and $tp{line}) {

            $where = "$tp{file}:$tp{line}" ;
        }
        else {

            askthem ("Bad tracepoint location.\n", 'OK' ) ;
            telme map {"$_ = $tp{$_}\n"} keys %tp ;
        }
        @tp{ qw/num enable inwhat exists where/ } = ('', 'y', "", 0) ;
    }

    $str = shift @lines ;
    if ($str and $str =~ /^\s*Actions.*\:/ ) {

        foreach $str ( @lines ) {

            $str =~ s/^\s+// ;
            $tact -> insert ('end',
                             $str => 'actions'
                             ) ;
        }
    }

    $str = gdb_exec_quiet ("i scope $where" ) ;
    @lines = split /^/, $str ;

    my @sym ;
    my $sym = '??' ;
    foreach ( @lines ) {

        if    ( /^Symbol\s+(\w+).*\*\)/ ) {
            push @sym, $1, "*$1"
        }
        elsif ( /^Symbol\s+(\w+)/       ) {
            push @sym, $1
        }
        elsif (/^(\w+)\s+.*\s+length\s+\d/) {
            push @sym, $sym = $1 ;
        }
        elsif (/^\s*\}\s*\*\s*\)\s*$/  ) {
            push @sym, "*$sym" ;
        }
    }

    foreach $sym (sort {starless $a cmp starless $b } @sym ) {

        if (length ( $text -> get ('end -1 c linestart' => 'end -1 c lineend')) +
            length ( $sym ) <
            $text -> cget ('-width') - 2 ) {
            $text -> insert ('end', ', '  => 'btext' ) ;
        }
        else {
            $text -> insert ('end', "\n " => 'btext' ) ;
        }

        $text -> insert ('end', $sym => 'llink' ) ;

    }

    $text -> configure (-state => 'disabled' ) ;
    return ;
}

sub try_to_save_actions {

    busy ;
                                # Algo: here Busy is used as a semaphore. I
                                # can't allow gdb io in between two actions commands.

    my ($r, $e, $p, $i) ;

    $r = $tact -> get( '1.0' => 'end' ) ;
    $r =~ s/\s+$//s ;
    my @lines = split /\n/, $r ;

    $tact -> tagRemove ('hlight', '1.0' => 'end') ;


    ($r, $e, $p) = gdb_exec_quiet( "passcount $tp{passcount} $tp{num}" ) ;
    telthem "$r:$e" if $r or $e ;

    ($r, $e, $p) = gdb_exec_quiet( "actions $tp{num}" ) ;

    return could_not_save_action( "$r $e" ) unless $p =~ $action_prompt ;

    foreach my $line ( @lines ) {
#         telme $line ;

        $i ++ ;

        $line || next ;
        $line =~ s/,\s*$// ;
        $line =~ s/^\s*collect\s+,/collect / ;

        ($r, $e, $p) = gdb_exec_quiet( $line ) ;

        return could_not_save_action( "$r$e", $i) if $r =~ /warning/i ;
        next if $p =~ $action_prompt ;

        last if ($i == @lines and $line =~ /end/) ;

        return could_not_save_action( "$r$e", $i )
    }

    for (0 .. 5) {
#         telme $p ;
        last if $p !~ $action_prompt ;
        ($r, $e, $p) = gdb_exec_quiet( 'end', 1 ) ;
    }

    if ( $p =~ $action_prompt ) {
        telme gdb_exec_quiet () ;
    }

    unbusy ;

    action_comment() ;
    hook_run 'show-data-tracepoints' ;
#    hook_run 'data-unraised-pane', 'Tracepoints' ;
    telthem "updated action to tracepoints $tp{num}" ;
}

sub could_not_save_action {

    my $msg  = shift ;
    my $line = shift ;

    $msg ||= gdb_exec_quiet() ;

    unbusy ;

    chomp $msg ;
    telthem $msg ;

    ($msg) = split /\n/, $msg ;

    action_comment( "Bogus: $msg" , 'rtext' ) ;

    $tact -> tagAdd ('hlight', "$line.0" => "$line.0 lineend" ) if $line ;
}

sub complete_action {

    my $cmd = $tact -> get ('current linestart' => 'current lineend' ) ;

    $tact -> delete ('current linestart' => 'current lineend') ;

    $cmd =~ s/^\s*// ;
    $cmd =~ s/\s*$// ;

    my $res = gdb_exec_quiet "complete $cmd" ;
    my @res = split /\n/, $res ;

    if     ( @res == 0 ) {

        $tact -> bell ;
    }
    elsif  ( @res == 1 ) {

        $cmd = $res[0] ;
    }
    else {

        my $i = length ($cmd) - 1 ;
        $cmd = shift @res ;

        while($i++) {
            my $char = substr($cmd, $i, 1) ;
            last if grep
            {$i > length($_) or substr($_, $i, 1) ne $char }
            @res ;
        }

        $cmd = substr($cmd, 0, $i) ;
        hook_run 'show-completions', $res ;
    }

    $tact -> insert ('current linestart',
                     $cmd => 'actions'
                     ) ;
    $tact -> break() ;
}

'end'
